home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / xscheme.arc / msstuff.c < prev    next >
C/C++ Source or Header  |  1989-01-29  |  8KB  |  392 lines
  1. /* msstuff.c - ms-dos specific routines */
  2.  
  3. #include <dos.h>
  4. #include "xscheme.h"
  5.  
  6. #define LBSIZE 200
  7.  
  8. /* external variables */
  9. extern LVAL s_unbound,true;
  10. extern FILE *tfp;
  11. extern int errno;
  12.  
  13. /* local variables */
  14. static char lbuf[LBSIZE];
  15. static int lpos[LBSIZE];
  16. static int lindex;
  17. static int lcount;
  18. static int lposition;
  19. static long rseed = 1L;
  20.  
  21. /* osinit - initialize */
  22. osinit(banner)
  23.   char *banner;
  24. {
  25.     printf("%s\n",banner);
  26.     lposition = 0;
  27.     lindex = 0;
  28.     lcount = 0;
  29. }
  30.  
  31. /* osfinish - clean up before returning to the operating system */
  32. osfinish()
  33. {
  34. }
  35.  
  36. /* oserror - print an error message */
  37. oserror(msg)
  38.   char *msg;
  39. {
  40.     printf("error: %s\n",msg);
  41. }
  42.  
  43. /* osrand - return a random number between 0 and n-1 */
  44. int osrand(n)
  45.   int n;
  46. {
  47.     long k1;
  48.  
  49.     /* make sure we don't get stuck at zero */
  50.     if (rseed == 0L) rseed = 1L;
  51.  
  52.     /* algorithm taken from Dr. Dobbs Journal, November 1985, page 91 */
  53.     k1 = rseed / 127773L;
  54.     if ((rseed = 16807L * (rseed - k1 * 127773L) - k1 * 2836L) < 0L)
  55.     rseed += 2147483647L;
  56.  
  57.     /* return a random number between 0 and n-1 */
  58.     return ((int)(rseed % (long)n));
  59. }
  60.  
  61. /* osaopen - open an ascii file */
  62. FILE *osaopen(name,mode)
  63.   char *name,*mode;
  64. {
  65.     return (fopen(name,mode));
  66. }
  67.  
  68. /* osbopen - open a binary file */
  69. FILE *osbopen(name,mode)
  70.   char *name,*mode;
  71. {
  72.     char bmode[10];
  73.     strcpy(bmode,mode); strcat(bmode,"b");
  74.     return (fopen(name,bmode));
  75. }
  76.  
  77. /* osclose - close a file */
  78. int osclose(fp)
  79.   FILE *fp;
  80. {
  81.     return (fclose(fp));
  82. }
  83.  
  84. /* ostell - get the current file position */
  85. long ostell(fp)
  86.   FILE *fp;
  87. {
  88.     return (ftell(fp));
  89. }
  90.  
  91. /* osseek - set the current file position */
  92. int osseek(fp,offset,whence)
  93.   FILE *fp; long offset; int whence;
  94. {
  95.     return (fseek(fp,offset,whence));
  96. }
  97.  
  98. /* osagetc - get a character from an ascii file */
  99. int osagetc(fp)
  100.   FILE *fp;
  101. {
  102.     return (getc(fp));
  103. }
  104.  
  105. /* osaputc - put a character to an ascii file */
  106. int osaputc(ch,fp)
  107.   int ch; FILE *fp;
  108. {
  109.     return (putc(ch,fp));
  110. }
  111.  
  112. /* osbgetc - get a character from a binary file */
  113. int osbgetc(fp)
  114.   FILE *fp;
  115. {
  116.     return (getc(fp));
  117. }
  118.  
  119. /* osbputc - put a character to a binary file */
  120. int osbputc(ch,fp)
  121.   int ch; FILE *fp;
  122. {
  123.     return (putc(ch,fp));
  124. }
  125.  
  126. /* ostgetc - get a character from the terminal */
  127. int ostgetc()
  128. {
  129.     int ch;
  130.  
  131.     /* check for a buffered character */
  132.     if (lcount--)
  133.     return (lbuf[lindex++]);
  134.  
  135.     /* get an input line */
  136.     for (lcount = 0; ; )
  137.     switch (ch = xgetc()) {
  138.     case '\r':
  139.         lbuf[lcount++] = '\n';
  140.         xputc('\r'); xputc('\n'); lposition = 0;
  141.         if (tfp)
  142.             for (lindex = 0; lindex < lcount; ++lindex)
  143.             osaputc(lbuf[lindex],tfp);
  144.         lindex = 0; lcount--;
  145.         return (lbuf[lindex++]);
  146.     case '\010':
  147.     case '\177':
  148.         if (lcount) {
  149.             lcount--;
  150.             while (lposition > lpos[lcount]) {
  151.             xputc('\010'); xputc(' '); xputc('\010');
  152.             lposition--;
  153.             }
  154.         }
  155.         break;
  156.     case '\032':
  157.         xflush();
  158.         return (EOF);
  159.     default:
  160.         if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
  161.             lbuf[lcount] = ch;
  162.             lpos[lcount] = lposition;
  163.             if (ch == '\t')
  164.             do {
  165.                 xputc(' ');
  166.             } while (++lposition & 7);
  167.             else {
  168.             xputc(ch); lposition++;
  169.             }
  170.             lcount++;
  171.         }
  172.         else {
  173.             xflush();
  174.             switch (ch) {
  175.             case '\003':    xltoplevel();    /* control-c */
  176.             case '\007':    xlcleanup();    /* control-g */
  177.             case '\020':    xlcontinue();    /* control-p */
  178.             case '\032':    return (EOF);    /* control-z */
  179.             default:        return (ch);
  180.             }
  181.         }
  182.     }
  183. }
  184.  
  185. /* ostputc - put a character to the terminal */
  186. ostputc(ch)
  187.   int ch;
  188. {
  189.     /* check for control characters */
  190.     oscheck();
  191.  
  192.     /* output the character */
  193.     if (ch == '\n') {
  194.     xputc('\r'); xputc('\n');
  195.     lposition = 0;
  196.     }
  197.     else {
  198.     xputc(ch);
  199.     lposition++;
  200.    }
  201.  
  202.    /* output the character to the transcript file */
  203.    if (tfp)
  204.     osaputc(ch,tfp);
  205. }
  206.  
  207. /* osflush - flush the terminal input buffer */
  208. osflush()
  209. {
  210.     lindex = lcount = lposition = 0;
  211. }
  212.  
  213. /* oscheck - check for control characters during execution */
  214. oscheck()
  215. {
  216.     int ch;
  217.     if (ch = xcheck())
  218.     switch (ch) {
  219.     case '\002':    /* control-b */
  220.         xflush();
  221.         xlbreak("BREAK",s_unbound);
  222.         break;
  223.     case '\003':    /* control-c */
  224.         xflush();
  225.         xltoplevel();
  226.         break;
  227.     case '\024':    /* control-t */
  228.         xinfo();
  229.         break;
  230.     case '\023':    /* control-s */
  231.         while (xcheck() != '\021')
  232.         ;
  233.         break;
  234.     }
  235. }
  236.  
  237. /* xinfo - show information on control-t */
  238. static xinfo()
  239. {
  240. /*
  241.     extern int nfree,gccalls;
  242.     extern long total;
  243.     char buf[80];
  244.     sprintf(buf,"\n[ Free: %d, GC calls: %d, Total: %ld ]",
  245.         nfree,gccalls,total);
  246.     errputstr(buf);
  247. */
  248. }
  249.  
  250. /* xflush - flush the input line buffer and start a new line */
  251. static xflush()
  252. {
  253.     osflush();
  254.     ostputc('\n');
  255. }
  256.  
  257. /* xgetc - get a character from the terminal without echo */
  258. static int xgetc()
  259. {
  260.     return (bdos(7,0,0) & 0xFF);
  261. }
  262.  
  263. /* xputc - put a character to the terminal */
  264. static xputc(ch)
  265.   int ch;
  266. {
  267.     bdos(6,ch,0);
  268. }
  269.  
  270. /* xcheck - check for a character */
  271. static int xcheck()
  272. {
  273.     return (bdos(6,0xFF,0) & 0xFF);
  274. }
  275.  
  276. /* xinbyte - read a byte from an input port */
  277. LVAL xinbyte()
  278. {
  279.     int portno;
  280.     LVAL val;
  281.     val = xlgafixnum(); portno = (int)getfixnum(val);
  282.     xllastarg();
  283.     return (cvfixnum((FIXTYPE)inp(portno)));
  284. }
  285.  
  286. /* xoutbyte - write a byte to an output port */
  287. LVAL xoutbyte()
  288. {
  289.     int portno,byte;
  290.     LVAL val;
  291.     val = xlgafixnum(); portno = (int)getfixnum(val);
  292.     val = xlgafixnum(); byte = (int)getfixnum(val);
  293.     xllastarg();
  294.     outp(portno,byte);
  295.     return (NIL);
  296. }
  297.  
  298. /* xint86 - invoke a system interrupt */
  299. LVAL xint86()
  300. {
  301.     union REGS inregs,outregs;
  302.     struct SREGS sregs;
  303.     LVAL inv,outv,val;
  304.     int intno;
  305.  
  306.     /* get the interrupt number and the list of register values */
  307.     val = xlgafixnum(); intno = (int)getfixnum(val);
  308.     inv = xlgavector();
  309.     outv = xlgavector();
  310.     xllastarg();
  311.  
  312.     /* check the vector lengths */
  313.     if (getsize(inv) != 9)
  314.         xlerror("incorrect vector length",inv);
  315.     if (getsize(outv) != 9)
  316.     xlerror("incorrect vector length",outv);
  317.  
  318.     /* load each register from the input vector */
  319.     val = getelement(inv,0);
  320.     inregs.x.ax = (fixp(val) ? (int)getfixnum(val) : 0);
  321.     val = getelement(inv,1);
  322.     inregs.x.bx = (fixp(val) ? (int)getfixnum(val) : 0);
  323.     val = getelement(inv,2);
  324.     inregs.x.cx = (fixp(val) ? (int)getfixnum(val) : 0);
  325.     val = getelement(inv,3);
  326.     inregs.x.dx = (fixp(val) ? (int)getfixnum(val) : 0);
  327.     val = getelement(inv,4);
  328.     inregs.x.si = (fixp(val) ? (int)getfixnum(val) : 0);
  329.     val = getelement(inv,5);
  330.     inregs.x.di = (fixp(val) ? (int)getfixnum(val) : 0);
  331.     val = getelement(inv,6);
  332.     sregs.es = (fixp(val) ? (int)getfixnum(val) : 0);
  333.     val = getelement(inv,7);
  334.     sregs.ds = (fixp(val) ? (int)getfixnum(val) : 0);
  335.     val = getelement(inv,8);
  336.     inregs.x.cflag = (fixp(val) ? (int)getfixnum(val) : 0);
  337.  
  338.     /* do the system interrupt */
  339.     int86x(intno,&inregs,&outregs,&sregs);
  340.  
  341.     /* store the results in the output vector */
  342.     setelement(outv,0,cvfixnum((FIXTYPE)outregs.x.ax));
  343.     setelement(outv,1,cvfixnum((FIXTYPE)outregs.x.bx));
  344.     setelement(outv,2,cvfixnum((FIXTYPE)outregs.x.cx));
  345.     setelement(outv,3,cvfixnum((FIXTYPE)outregs.x.dx));
  346.     setelement(outv,4,cvfixnum((FIXTYPE)outregs.x.si));
  347.     setelement(outv,5,cvfixnum((FIXTYPE)outregs.x.di));
  348.     setelement(outv,6,cvfixnum((FIXTYPE)sregs.es));
  349.     setelement(outv,7,cvfixnum((FIXTYPE)sregs.ds));
  350.     setelement(outv,8,cvfixnum((FIXTYPE)outregs.x.cflag));
  351.     
  352.     /* return the result list */
  353.     return (outv);
  354. }
  355.  
  356. /* getnext - get the next fixnum from a list */
  357. static int getnext(plist)
  358.   LVAL *plist;
  359. {
  360.     LVAL val;
  361.     if (consp(*plist)) {
  362.         val = car(*plist);
  363.     *plist = cdr(*plist);
  364.     if (!fixp(val))
  365.         xlerror("expecting an integer",val);
  366.         return ((int)getfixnum(val));
  367.     }
  368.     return (0);
  369. }
  370.  
  371. /* xsystem - execute a system command */
  372. LVAL xsystem()
  373. {
  374.     char *cmd="COMMAND";
  375.     if (moreargs())
  376.     cmd = (char *)getstring(xlgastring());
  377.     xllastarg();
  378.     return (system(cmd) == 0 ? true : cvfixnum((FIXTYPE)errno));
  379. }
  380.  
  381. /* xgetkey - get a key from the keyboard */
  382. LVAL xgetkey()
  383. {
  384.     xllastarg();
  385.     return (cvfixnum((FIXTYPE)xgetc()));
  386. }
  387.